C  ******** INTPLY.F4 ***********
C  THIS PROGRAM GIVES TRAINING IN THE NAMES OF MUSICAL INTERVALS AS WELL AS
C  GIVING DICTATION OF TWO-NOTE INTERVAL EXAMPLES.  TO RESET THE
C  SPECIAL ERROR MESSAGE TYPE 99999<CR>, THEN THE MESSAGE (PRECEDED BY ONE
C  BLANK).  TO EXIT FROM THE PROGRAM TYPE 'X'.  FIVE CHANCES ARE GIVEN FOR
C  EACH QUESTION.  NO ERRORS ARE COUNTED FOR MOST TYPING MISTAKES.
C  TYPE 'R' TO REPEAT SOUND EXAMPLES, 'Z' TO GET ANSWER.
C  DOUBLE SHARPS MAY BE USED WITH C, D, F, G AND A.  DOUBLE FLATS MAY BE
C  USED WITH D, E, G, A AND B.  AUG5, AUG6 AND DIM3 INTERVALS ARE OK.
C  RAN NUM ≥9999 ACTIVATES SINGINGC  ******** INTPLY.F4 ***********
C  THIS PROGRAM GIVES TRAINING IN THE NAMES OF MUSICAL INTERVALS AS WELL AS
C  GIVING DICTATION OF TWO-NOTE INTERVAL EXAMPLES.  TO RESET THE
C  SPECIAL ERROR MESSAGE TYPE 99999<CR>, THEN THE MESSAGE (PRECEDED BY ONE
C  BLANK).  TO EXIT FROM THE PROGRAM TYPE 'X'.  FIVE CHANCES ARE GIVEN FOR
C  EACH QUESTION.  NO ERRORS ARE COUNTED FOR MOST TYPING MISTAKES.
C  TYPE 'R' TO REPEAT SOUND EXAMPLES, 'Z' TO GET ANSWER.
C  DOUBLE SHARPS MAY BE USED WITH C, D, F, G AND A.  DOUBLE FLATS MAY BE
C  USED WITH D, E, G, A AND B.  AUG5, AUG6 AND DIM3 INTERVALS ARE OK.
C  RAN NUM ≥9999 ACTIVATES SINGING PRACTICE MODE.
C**** LOAD WITH  DICTBT.FAI AND BRZ.REL 
C**** ALSO NEEDS 25 SOUND FILES (ON DTA).

	DIMENSION KAC(3),LAC(5),IDIR(2),NT(7),IVL(24),NTX(24),JNT(25)
	1 ,ISS(6),MSGE(6)
	DATA JNT/'C','CS','D','DS','E','F','FS','G','GS','A','AS','B'
	1,'C5','CS5','D5','DS5','E5','F5','FS5','G5'
	1,'GS5','A5','AS5','B5','C6'/,ISS/'CSS','DSS',0,'FSS','GSS'
	1,'ASS'/,MSGE(3)/'WRONG'/
	DATA NT/'C','D','E','F','G','A','B'/,KAC/' ','F ','# '/,IDIR/'DOWN
	1',' UP '/,LAC/'FF','F ','  ','# ','##'/,IVL/'MN2','MN2','MJ2',
	1'MJ2','AU2','MN3','MJ3','MJ3','P4','P4','AU4','DM5','P5','P5',
	1'MN6','MN6','MJ6','DM7','MN7','MN7','MJ7','MJ7','P8','OCT'/
	DATA NTX/'C','DFF','CS','DF','D','EFF','DS','EF','E','FF','F',
	1 'GFF','FS','GF','G','AFF','GS','AF','A','BFF','AS','BF','B','CF'/
	CALL RNDINT
	CNT=0
	TYPE='TYPE '
	TYPE 255
	ACCEPT 202,MODE
	TYPE 205
	ACCEPT 310,LRAN
C   NEXT CHECKS SYS.
	IF(MODE.EQ.'S')TYPE='SING '
	IF(LRAN.EQ.99999)ACCEPT 202,MSGE
C  SPECIAL ERROR MESS. FOR 'EARS' - UP TO 22 CHARACTERS.(LEAVE 1 BLANK)
	IF(MODE.NE.'L')GO TO 51
	TYPE 52
	CALL PLAY(NT(6),J,0,JP)
51	IF(LRAN.GT.9999)LRAN=LRAN/100
C   LIMIT RAN NUM TO <10000.
C  FOR MOST AUG AND DIM INTERVALS, MAKE RAN NUM >499.
C  FOR SIMPLEST QUESTIONS, RAN NUM MUST BE <100.(USES MOSTLY NATURALS)
	XRAN=1.0
	RAN=23.99
	IOK=0
	IERR=0
	DO 50 K=1,LRAN
50	X=RAND(0.0,0.0)		
	IF(MODE.EQ.'L')LRAN=0
C  WHY NEEDED? 'L' DOES NOT WORK RIGHT IF LRAN>499!!!!! (SEE 13300?) 12/29/71
100	N1=RAND(1.0,7.99)
	IF(N1.EQ.NOTE)GO TO 100
C   NOTE WILL NOT REPEAT.
	NOTE=N1
	JP=0
	IF(CNT.NE.7..OR.MODE.EQ.'S')GO TO 104
	TYPE 1400
C   TYPES 'PRAISE'
	CNT=0
104	IF(LRAN.LT.500)GO TO 105
	XRAN=1.0+CNT/2.0
C  AS CNT GOES UP, RAN SELECTION RANGE INCREASES.
	RAN=23.99+CNT
	IF(RAN.GT.28.)XRAN=23.0
105	CNT=CNT+1.
108	I=RAND(XRAN,RAN)
	IF(I.EQ.23.AND.MODE.NE.'L')GO TO 108
C  23 TO 28 MAKE UP FOR  AU2,MN3 CO0.(USES MOSTLY NATURALS)
	XRAN=1.0
	RAN=23.99
	IOK=0
	IERR=0
	DO 50 K=1,LRAN
50	X=RAND(0.0,0.0)		
	IF(MODE.EQ.'L')LRAN=0
C  WHY NEEDED? 'L' DOES NOT WORK RIGHT IF LRAN>499!!!!! (SEE 13300?) 12/29/71
100	N1=RAND(1.0,7.99)
	IF(N1.EQ.NOTE)GO TO 100
C   NOTE WILL NOT REPEAT.
	NOTE=N1
	JP=0
	IF(CNT.NE.7..OR.MODE.EQ.'S')GO TO 104
	TYPE 1400
C   TYPES 'PRAISE'
	CNT=0
104	IF(LRAN.LT.500)GO TO 105
	XRAN=1.0+CNT/2.0
C  AS CNT GOES UP, RAN SELECTION RANGE INCREASES.
	RAN=23.99+CNT
	IF(RAN.GT.28.)XRAN=23.0
105	CNT=CNT+1.
108	I=RAND(XRAN,RAN)
	IF(I.EQ.23.AND.MODE.NE.'L')GO TO 108
C  23 TO 28 MAKE UP FOR  AU2,MN3 COMBI, ETC.
1108	IF(I.LT.24)GO TO 103
	IF(I.GE.27)I=I-10
	IF(I.GE.25)I=I-14
	IF(I.GE.23)I=I-18
103	JAC=RAND(0.0,2.99)
C  JAC PICKS ACCIDENTAL   0=NAT.  1=b  2=#
	IF(JAC.EQ.0)GO TO 102
	IF(LRAN.LT.100)JAC=0
	IF(JAC.EQ.1.AND.(N1.EQ.1.OR.N1.EQ.4))GO TO 103
	IF(JAC.EQ.2.AND.(N1.EQ.3.OR.N1.EQ.7))GO TO 103
C   CHECKS FOR Cb, Fb, E#, B#
102	INTVL=(I+1)/2+1
C   SMALLEST INTERVAL IS 1/2 STEP.
	NAC=3
C  NAC IS ACCID. FOR 2ND NOTE.  SEE LAC (IN DATA) FOR ORDER.
	IF(I.GT.5)GO TO 10
	N2=2
	GO TO 101
10	IF(I.LT.18)GO TO 20
	N2=7
	GO TO 101
20	N2=(I-3)/3+2
101	IF(I.EQ.5.OR.I.EQ.11)NAC=4
	IF(INTVL.EQ.2.OR.I.EQ.6.OR.I.EQ.12.OR.INTVL.EQ.9.OR.INTVL.EQ.11)
	1 NAC=2
	IF(I.EQ.18)NAC=1
	GO TO (1,2,3,4,5,6,7),N1
C   WHICH NAME FOR NOTE 1?
4	IF(N2.EQ.4)NAC=NAC-1
	GO TO 1
7	IF(N2.EQ.5)GO TO 99
3	IF(N2.EQ.2)GO TO 99
6	IF(N2.EQ.6)GO TO 99
2	IF(N2.EQ.3)GO TO 99
5	IF(N2.EQ.7)GO TO 99
C  USES 'REASONABLE' INTERVALS
	GO TO 1
99	NAC=NAC+1
1	N2=N2+N1-1
	IF(N2.GT.7)N2=N2-7
C  KEEP NOTE 2 WITHIN MUSICAL ALPHABET (C→B)
	NAC=NAC-JAC
	IF(JAC.EQ.2)NAC=NAC+3
	JAC=JAC+1
C  WORKS OUT FINAL FORM OF ACCIDENTALS
9	JDIR=RAND(1.0,2.99)
C  JDIR IS DIRECTION OF LEAP (2=UP  1=DOWN]
	IF(JDIR.EQ.2)GO TO 2000
	K=N2
	KA=LAC(NAC)
C  KA=ACCID. OF 2ND NOTE.
	L=N1
	LA=KAC(JAC)
C  LA=ACCID. OF 1ST NOTE.
	GO TO 1000
2000	IF(NAC.EQ.1.OR.NAC.EQ.5)GO TO 9
C   AVOIDS 'FF' AND '##'
	K=N1
	KA=KAC(JAC)
	L=N2
	LA=LAC(NAC)
1000	IF(KA.EQ.'FF'.OR.KA.EQ.'##')GO TO 108
C  TRY AGAIN IF 'FUNNY' NOTE IS PICKED.
	IF(LRAN.GE.500)GO TO 204
	IF(((K.EQ.4.OR.K.EQ.1).AND.KA.EQ.'F').OR.((K.EQ.3.OR.K.EQ.7)
	1.AND.KA.EQ.'#'))GO TO 108
C  AVOIDS FF,CF,E#,B# IN TYPEOUT
	N1=K
	N2=L
204	IQUES=RAND(1.0,4.99)
C  WHICH MODE OF QUESTION?
	INTVL=INTVL-1
	KANS=' '
	ITRY=IERR+4
2104	IF(IQUES.LT.3)GO TO 3000
	IF(MODE.EQ.'L')GO TO 2041
	TYPE 201,TYPE,IVL(I),IDIR(JDIR),NT(K),KA
C	     INTERVAL  DIRECTION  NOTE  ACCIDENTAL
	IF(MODE.EQ.'S')GO TO 3003
	KANS=NT(L)
	JANS=LA
C  KANS AND JANS STORE INFO TO GIVE ANSWER WHEN 5 ERRORS ARE MADE.
203	ACCEPT 202,L1,L2
	IF(L1.EQ.'X')GO TO 106
C  X=EXIT FROM PROGRAM
	IF(L1.EQ.'Z')GO TO 445
	IF(L2.EQ.'S')L2='#'
	IF(L2.EQ.'SS')L2='##'
	IF(L1.NE.NT(L).OR.L2.NE.LA)GO TO 444
C  NOTE NAME(L1) AND ACCID.(L2) CORRECT?
107	IOK=IOK+1
3005	TYPE 301
	GO TO 100
445	IF(JANS.EQ.'OCT')JANS='P8'
	TYPE 304,KANS,JANS
	CNT=CNT-1.
	IF(L1.NE.'Z')TYPE 302
	GO TO 100
3000	IF(MODE.EQ.'L')GO TO 3003
C   TO 3003 IS TEMPORARY
	TYPE 200,NT(K),KA,IDIR(JDIR),NT(L),LA
	IF(MODE.EQ.'S')GO TO 3003
	JANS=IVL(I)
30	ACCEPT 300,L1
	IF(L1.EQ.'X')GO TO 106
	IF(L1.EQ.'Z')GO TO 445
	IF(L1.EQ.JANS)GO TO 107
C  ADD HERE CHECK ON MODE OF ANSWER*******
444	IF(L1.NE.' ')IERR=IERR+1
	IF(ITRY.EQ.IERR)GO TO 445
	LX=RAND(1,5.99)		
	IF(CNT.GT.0)CNT=CNT-1
C   RESETS 'PRAISE' COUNTER
	GO TO (81,82,83,84,85),LX
81	IF(MODE.EQ.'L')GO TO 811
	TYPE 1200
	GO TO 333
811	TYPE 801
	GO TO 333
82	TYPE 800
	GO TO 333
83	TYPE 900
	GO TO 333
84	IF(MODE.EQ.'L')GO TO 841
	TYPE 1300
	GO TO 333
841	TYPE 802
	GO TO 333
85	IF(MODE.EQ.'L')GO TO 851
	TYPE 1100
	GO TO 333
851	TYPE 202,MSGE
333	TYPE 400
	IF(MODE.EQ.'L')GO TO 2014
	IF(IQUES.GT.2)GO TO 203
	GO TO 30
2041	X=13.5
	Y=1.
	IF(JDIR.EQ.1)Y=25.99
C  RANGE IS C4→C5 OR C4→C3 FOR 1ST NOTE.
	K=RAND(X,Y)
	L=K+INTVL
	IF(JDIR.EQ.1)L=K-INTVL
C  UP OR DOWN?
	NTA=JNT(K)
	NTB=JNT(L)
	KQUES=2
	JANS=IVL(INTVL*2)
32	TYPE 702
2014	TYPE 53
	ACCEPT 300,J
	IF(J.EQ.'X')GO TO 106
2045	CALL PLAY(NTA,NTB,IQUES,JP)
	IF(IQUES.NE.4)CALL PLAY(NTB,J,0,JP)
2044	TYPE 54
	ACCEPT 300,L1
	K=0
	IF(L1.EQ.'X')GO TO 106
	IF(L1.EQ.'Z')GO TO 445
	IF(L1.EQ.'ES')L1='F'
	IF(L1.EQ.'BS')L1='C'
	IF(L1.EQ.'R')GO TO 2045
	IF(KQUES.EQ.3)GO TO 3006
	DO 2042 L=1,23
	IF(L1.NE.IVL(L))GO TO 2042
	K=(L+1)/2
	GO TO 2043
2042	CONTINUE
	IF(L1.EQ.'AU5')K=8
	IF(L1.EQ.'AU6')K=10
	IF(L1.EQ.'DM3')K=2 
C  2 STEPS FOR EACH INTERVAL.
2043	IF(K.EQ.INTVL)GO TO 107
	IF(K.EQ.0)GO TO 446
C   WRONG CLASS OF ANSWER?
	GO TO 444
446	TYPE 303
	GO TO 2044
3003	KQUES=3
	N=N1*2-1
	IF(N1.GT.3)N=N-1
	IF(JDIR.EQ.1)N=N+12
	IF(KA.EQ.'#')N=N+1
	IF(KA.EQ.'F')N=N-1
	NTA=JNT(N)
	J=N+INTVL
	IF(JDIR.EQ.1)J=N-INTVL
	NTB=JNT(J)
	IF(MODE.EQ.'S')GO TO 60
	IF(IQUES.EQ.2)GO TO 33
	JANS=MOD(J,12)
	NTA=NTB
	NTB=JNT(N)
35	TYPE 701,NT(K),KA
	GO TO 34
33	TYPE 700,NT(K),KA
	JANS=MOD(J,12)
34	IF(JANS.EQ.0)JANS=12
	JANS=JNT(JANS)
	GO TO 2014
60	JP=0
	CALL PLAY(NTA,0,1,JP)
	JP=0
	TYPE 53
	ACCEPT 202,X
	IF(X.EQ.'X')CALL EXIT
	IF(X.EQ.'R')GO TO 60
61	CALL PLAY(NTB,0,1,JP)
	TYPE 302
	ACCEPT 202,X
	IF(X.EQ.'X')CALL EXIT
	IF(X.EQ.'R')GO TO 2104
C  'R' REPEATS LAST ACTION.
	GO TO 100

3006	DO 40 J=1,24
	IF(NTX(J).NE.L1)GO TO 40
	L=(J+1)/2
	GO TO 42
40	CONTINUE
C  BRINGS DOWN WITHIN 12 TONES.
	DO 41 J=1,6
	IF(ISS(J).NE.L1)GO TO 41
C  LOOKS FOR DOUBLE SHARPS
	L=J*2
	IF(J.LT.4)L=L+1
	GO TO 42
41	CONTINUE
	GO TO 446
42	N=N1*2-1
	IF(N1.GT.3)N=N-1
	J=N
	IF(KA.EQ.'F')J=J-1
	IF(KA.EQ.'#')J=J+1
	N=J-L
C 1ST NOTE - 2ND NOTE
	IF(JDIR.EQ.2)N=L-J
	IF(N.LE.0)CALL PLAY(NTA,0,1,JP)
	JP=0
	TYPE 53
	ACCEPT 202,X
	IF(X.EQ.'X')CALL EXIT
	IF(X.EQ.'R')GO TO 60
61	CALL PLAY(NTB,0,1,JP)
	TYPE 302
	ACCEPT 202,X
	IF(X.EQ.'X')CALL EXIT
	IF(X.EQ.'R')GO TO 2104
C  'R' REPEATS LAST ACTION.
	GO TO 100

3006	DO 40 J=1,24
	IF(NTX(J).NE.L1)GO TO 40
	L=(J+1)/2
	GO TO 42
40	CONTINUE
C  BRINGS DOWN WITHIN 12 TONES.
	DO 41 J=1,6
	IF(ISS(J).NE.L1)GO TO 41
C  LOOKS FOR DOUBLE SHARPS
	L=J*2
	IF(J.LT.4)L=L+1
	GO TO 42
41	CONTINUE
	GO TO 446
42	N=N1*2-1
	IF(N1.GT.3)N=N-1
	J=N
	IF(KA.EQ.'F')J=J-1
	IF(KA.EQ.'#')J=J+1
	N=J-L
C 1ST NOTE - 2ND NOTE
	IF(JDIR.EQ.2)N=L-J
	IF(N.LE.0)N=N+12
	IF(MODE.EQ.'S')GO TO 60
	IF(N.NE.INTVL)GO TO 444
	GO TO 107
106	XRAN=IOK
	RAN=IERR
	K=XRAN/(XRAN+RAN)*100.
	IF(IOK.GT.5.AND.K.GE.85)TYPE 2500
C  'PRAISE' IF OVER 85% OK.
	IF(IERR.GT.5.AND.IERR.GT.IOK)TYPE 2600
C  UNDER 50%!!!!!
	TYPE 2400,IOK,K,IERR
52	FORMAT(' THIS IS ''A'' (440HZ)'/)
53	FORMAT(' PLAY?'$)
54	FORMAT(' ANSWER:'$)
300	FORMAT(A3)
301	FORMAT(' CORRECT!'/)
302	FORMAT(' TRY A NEW QUESTION'/)
400	FORMAT(' TRY AGAIN'/)
200	FORMAT(' FROM ',A1,A2,1XA4,' TO ',A1,A2,'?'/)
201	FORMAT(1XA5,A3,1XA4,' FROM ',A1,A2/)
202	FORMAT(A1,A2,4A5)
303	FORMAT(' WRONG TYPE OF ANSWER'/)
304	FORMAT(' THE ANSWER IS: ',A1,A3/)
205	FORMAT(' F=FLAT, S=SHARP, FF OR SS=DOUBLE FLAT OR SHARP'/
	1' MN=MINOR, MJ=MAJOR, P=PERFECT, DM=DIMISHED, AU=AUGMENTED'/
	1//' TYPE <R> FOR REPEAT, <Z> FOR ANSWER, <X> FOR EXIT'/
	1/' TYPE A RANDOM NUMBER'/)
255	FORMAT(' WRITE, LISTEN, SING?'/)
310	FORMAT(I)
800	FORMAT(' NOT QUITE RIGHT')
801	FORMAT(' CLEAN YOUR EARS')
802	FORMAT(' LISTEN CAREFULLY')
700	FORMAT(' THE 1ST NOTE IS ',A1,A2,' -- THE 2ND IS?'/)
701	FORMAT(' THE 2ND NOTE IS ',A1,A2,' -- THE 1ST IS?'/)
702	FORMAT(' THE INTERVAL IS?'/)
900	FORMAT(' THAT DOES NOT COMPUTE')
1300	FORMAT(' CHECK YOUR NOTES')
1100	FORMAT(' PERHAPS YOU MISUNDERSTOOD')
1200	FORMAT(' WRITE IT ON MUSIC PAPER')
1400	FORMAT(' GOOD WORK!'/)
2400	FORMAT(' YOU HAD ',I2,' CORRECT ANSWERS,',I4,'%'/I3,' ERRORS.')
2600	FORMAT(' MORE STUDY PLEASE!')
2500	FORMAT(' CONGRATULATIONS!')
	END
	SUBROUTINE PLAY(NAME,NM2,IQUES,J)
	INTEGER SOUND,SOUND2
	DIMENSION SOUND(1024),SOUND2(1024),N(3),M(3),L(3)
	EQUIVALENCE (M1,M(1)),(M2,M(2)),(M3,M(3)),(N1,N(1)),
	1 (N2,N(2)),(N3,N(3)),(L1,L(1)),(L2,L(2)),(L3,L(3))
	IF(J.EQ.-10)GO TO 3
	I=1024
	CALL GETFILE(NAME)
	CALL FASTIN(SOUND(1),1024)
	IF(IQUES.NE.4)GO TO 3

	J=RAND(0.0,700.0)
	IF(J.GT.500)J=0
	I=I+J
	CALL GETFILE(NM2)
	CALL FASTIN(SOUND2(1),1024)
	N1=0
	N2=0
	N3=0

	DO 1 K=1,I
	IF(K.LT.1025)  CALL UNPACK(SOUND(K),M)
	IF(K.GT.J)  CALL UNPACK(SOUND2(K-J),N)
	L1=(M1+N1)/2
	L2=(M2+N2)/2
	L3=(M3+N3)/2
	CALL REPACK(SOUND(K),L)
	IF(K.NE.1024)GO TO 1
	M1=0
	M2=0
	M3=0
1	CONTINUE
	J=-10
	CALL D2A(SOUND(1),I)

3	CALL D2A(SOUND(1),I)
	RETURN
	END